home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 7 / Apprentice-Release7.iso / Source Code / C / Applications / Moscow ML 1.42 / src / !runtime / extern.c < prev    next >
Encoding:
C/C++ Source or Header  |  1997-08-18  |  3.6 KB  |  154 lines  |  [TEXT/R*ch]
  1. /* Structured output, fast format */
  2.  
  3. #include "debugger.h"
  4. #include "fail.h"
  5. #include "gc.h"
  6. #include "intext.h"
  7. #include "io.h"
  8. #include "memory.h"
  9. #include "mlvalues.h"
  10.  
  11. struct extern_obj * extern_table;
  12. asize_t extern_table_size, extern_table_used;
  13.  
  14. void alloc_extern_table()
  15. {
  16.   asize_t i;
  17.  
  18.   extern_table = (struct extern_obj *)
  19.     stat_alloc(extern_table_size * sizeof(struct extern_obj));
  20.   for (i = 0; i < extern_table_size; i++)
  21.     extern_table[i].obj = 0;
  22. }
  23.  
  24. void resize_extern_table()
  25. {
  26.   asize_t oldsize;
  27.   struct extern_obj * oldtable;
  28.   asize_t i, h;
  29.  
  30.   oldsize = extern_table_size;
  31.   oldtable = extern_table;
  32.   extern_table_size = 2 * extern_table_size;
  33.   alloc_extern_table();
  34.   for (i = 0; i < oldsize; i++) {
  35.     h = Hash(oldtable[i].obj);
  36.     while (extern_table[h].obj != 0) {
  37.       h++;
  38.       if (h >= extern_table_size) h = 0;
  39.     }
  40.     extern_table[h].obj = oldtable[i].obj;
  41.     extern_table[h].ofs = oldtable[i].ofs;
  42.   }
  43.   stat_free((char *) oldtable);
  44. }
  45.  
  46. static byteoffset_t * extern_block;
  47. static asize_t extern_size, extern_pos;
  48.  
  49. static void resize_result()
  50. {
  51.   extern_size = 2 * extern_size;
  52.   extern_block = (byteoffset_t *)
  53.     stat_resize((char *) extern_block, extern_size * sizeof(byteoffset_t));
  54. }
  55.  
  56. static byteoffset_t emit(v)
  57.      value v;
  58. {
  59.   mlsize_t size;
  60.   asize_t h;
  61.   byteoffset_t res;
  62.   value * p;
  63.   byteoffset_t * q;
  64.   asize_t end_pos;
  65.  
  66.   if (Is_long(v)) return (byteoffset_t) v;
  67.   size = Wosize_val(v);
  68.   if (size == 0) return (Tag_val(v) << 2) + 2;
  69.   if (2 * extern_table_used >= extern_table_size) resize_extern_table();
  70.   h = Hash(v);
  71.   while (extern_table[h].obj != 0) {
  72.     if (extern_table[h].obj == v) return extern_table[h].ofs;
  73.     h++;
  74.     if (h >= extern_table_size) h = 0;
  75.   }
  76.   end_pos = extern_pos + 1 + size;
  77.   while (end_pos >= extern_size) resize_result();
  78.   /* Consistently write the header's color, i.e. gc bits, to the file: */
  79.   extern_block[extern_pos++] = Make_header(size, Tag_val(v), Black);
  80.   res = extern_pos * sizeof(byteoffset_t);
  81.   extern_table[h].obj = v;
  82.   extern_table[h].ofs = res;
  83.   extern_table_used++;
  84.   for (p = &Field(v, 0), q = &extern_block[extern_pos]; size > 0; size--) {
  85.     *q++ = *p++;
  86.   }
  87.   extern_pos = end_pos;
  88.   return res;
  89. }
  90.  
  91. static byteoffset_t emit_all(root)
  92.      value root;
  93. {
  94.   asize_t read_pos;
  95.   byteoffset_t res;
  96.   header_t hd;
  97.   mlsize_t sz;
  98.   byteoffset_t ofs;
  99.  
  100.   read_pos = extern_pos;
  101.   res = emit(root);
  102.   while (read_pos < extern_pos) {
  103.     hd = (header_t) extern_block[read_pos++];
  104.     sz = Wosize_hd(hd);
  105.     switch(Tag_hd(hd)) {
  106.     case String_tag:
  107.     case Double_tag:
  108.       read_pos += sz;
  109.       break;
  110.     case Abstract_tag:
  111.     case Final_tag:
  112.       invalid_argument("output_value: abstract value");
  113.       break;
  114.     case Closure_tag:
  115.       invalid_argument("output_value: functional value");
  116.       break;
  117.     default:
  118.       while (sz > 0) {
  119.         ofs = emit((value) extern_block[read_pos]);
  120.         extern_block[read_pos] = ofs;
  121.         read_pos++;
  122.         sz--;
  123.       }
  124.       break;
  125.     }
  126.   }
  127.   return res;
  128. }
  129.  
  130. value extern_val(chan, v)       /* ML */
  131.      struct channel * chan;
  132.      value v;
  133. {
  134.   byteoffset_t res;
  135.  
  136.   extern_size = INITIAL_EXTERN_SIZE;
  137.   extern_block =
  138.     (byteoffset_t *) stat_alloc(extern_size * sizeof(unsigned long));
  139.   extern_pos = 0;
  140.   extern_table_size = INITIAL_EXTERN_TABLE_SIZE;
  141.   alloc_extern_table();
  142.   extern_table_used = 0;
  143.   res = emit_all(v);
  144.   stat_free((char *) extern_table);
  145.   putword(chan, Extern_magic_number);
  146.   putword(chan, extern_pos);
  147.   if (extern_pos == 0)
  148.     putword(chan, res);
  149.   else
  150.     putblock(chan, (char *) extern_block, extern_pos * sizeof(unsigned long));
  151.   stat_free((char *) extern_block);
  152.   return Val_unit;
  153. }
  154.